COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(declare (fasload struct fas dsk (mac lsp)))
C00011 ENDMK
C⊗;
(declare (fasload struct fas dsk (mac lsp)))

(defstruct node-record
 (count 0)
 (in-degree 0)
 (name nil)
 (qlink nil)
 (direct-superclasses ())
 (pseudo-order 0)
 (lv-visits 0)
 (top nil))

(defmacro unless (x . y) `(cond ((not ,x) ,@y)))

(defmacro when (x . y) `(cond (,x ,@y)))

(defmacro incf (loc) `(setf ,loc (+ ,loc 1)))

(defmacro decf (loc) `(setf ,loc (+ ,loc -1)))

(defmacro node-record (node) `(cadr ,node))

(defmacro loop forms `(do () (()) ,@forms))

(defmacro dolist ((stepper starter) .forms)
 (let ((var (gensym)))
 `(do ((,var ,starter (cdr ,var))
       (,stepper nil))
      ((null ,var))
   (setq ,stepper (car ,var))
   ,@forms)))

(defun union (l1 l2)
 (do ((l1 l1 (cdr l1))
      (l l2))
     ((null l1) l)
     (unless (memq (car l1) l2) (push (car l1) l))))

(declare (special *node-alist*) (special *n*))

(defmacro node-record-exists (node) `(assq ,node *node-alist*))

(defmacro find-node-record (node) `(cadr (assq ,node *node-alist*)))

(defun init () (setq *node-alist* nil) (setq *n* 0))

(defmacro defclass (class superclasses ignore)
 (let ((class-record ()))
  (let ((class-record-entry (node-record-exists class)))
   (cond (class-record-entry
	  (setq class-record (node-record class-record-entry)))
	 (t (incf *n*)
	    (setq class-record (make-node-record name class))
	    (push `(,class ,class-record) *node-alist*))))
  (when superclasses
   (let ((class1-record ())
	 (class2-record ()))
     (let ((class1-record-entry (node-record-exists (car superclasses))))
      (cond (class1-record-entry
	     (setq class1-record (node-record class1-record-entry)))
	    (t (incf *n*)
	       (setq class1-record (make-node-record name (car superclasses)))
	       (push 
	       ` (,(car superclasses) ,class1-record) *node-alist*))))
   (do ((sc superclasses (cdr sc))
        (ds nil))
       ((null sc) (setf (direct-superclasses class-record) (reverse ds)))
    (let ((class2 (cadr sc)))
     (push class1-record ds)
     (incf (in-degree class1-record))
     (when class2
      (let ((class2-record-entry (node-record-exists class2)))
       (cond (class2-record-entry
	      (setq class2-record (node-record class2-record-entry)))
	     (t (incf *n*)
	        (setq class2-record (make-node-record name class2))
	        (push 
		` (,class2 ,class2-record) *node-alist*))))
      (record-relation class1-record class2-record))
     (record-relation class-record class1-record)
     (setq class1-record class2-record))))))
 `(quote ,class))

;;; Records that node1<node2
;;;
(defun record-relation (node1-record node2-record)
  (incf (count node2-record))
  (setf (top node1-record) (cons node2-record (top node1-record)))
  (name node1-record))

(declare (special *preorder-counter*))

;;; This does a last-visited preorder treewalk from the class for which
;;; we are calculating the class precedence list. It assigns
;;; pseudo-order numbers to each node, which is the order in which
;;; the preorder walk encountered the node for the last time.
;;;
(defun lv-preorder-walk (class)
 (incf (lv-visits class))
 (unless (< (lv-visits class) (in-degree class))
	 (setf (pseudo-order class) (incf *preorder-counter*))
	 (dolist (superclass (direct-superclasses class))
		 (lv-preorder-walk superclass))))

(defun find-loop (class)
 (let ((ans
	(cond ((< 0 (count class))
	       `(,(name class)))
	      (t ()))))
      (dolist (superclass (direct-superclasses class))
	      (setq ans (union (find-loop superclass) ans)))
      ans))

;;; This inserts a node-record in the right place in the queue
;;; of nodes with no predecessors, using the pseudo-order to
;;; sort them.
;;;
(defmacro insert-node (front rear node-record)
 `(let ((pseudo-order (pseudo-order ,node-record)))
   (do ((current-node ,front next-node)
        (next-node (qlink ,front) (qlink next-node)))
       ((eq next-node none)
        ;; We're at the end
        (setf (qlink ,rear) ,node-record)
        (setq ,rear ,node-record))
    (cond ((< pseudo-order (pseudo-order next-node))
  	   (setf (qlink current-node) ,node-record)
	   (setf (qlink ,node-record) next-node)
	   (return t))))))

(defun topologically-sort (class-name)
 (let ((*preorder-counter* 0))
  (lv-preorder-walk (find-node-record class-name)))
 (let* ((cpl nil)
	(unique-total-order t)
	(none (ncons ()))
	(dummy-node (make-node-record name none qlink none))
	(front dummy-node)
	(rear dummy-node))
  ;; Link together the nodes with count=0 (no predecessors)
  (dolist (node *node-alist*)
   (setf (qlink (node-record node)) none)
   (when (zerop (count (node-record node)))
	 (insert-node front rear (node-record node))))
  (setq front (qlink dummy-node))
  ;; Do the sort
  (loop
   (when (eq front none) 
	 (cond ((zerop *n*) (return cpl))
	       (t 
		(princ `|Loop found: |)
		(princ (find-loop (find-node-record class-name)))
		(terpri)
		(princ '|Current order: |)
		(princ (reverse cpl))
		(terpri)
		(error '|Inconsistent Lattice|)
		  (return nil))))
   (push (name front) cpl)
   ;; Could a different 0-count node be output next?
   (unless (eq front rear) (setq unique-total-order nil))
   (decf *n*)
   ;; Recalculate the counts and queue of 0-count nodes
   (dolist (p (top front))
    (when (zerop (decf (count p))) (insert-node front rear p)))
   (setq front (qlink front)))
  ;; See if a choice was ever possible
  (unless unique-total-order 
	  (princ "Multiple Total Orders Possible")
	  (terpri))
  (reverse cpl)))